(defpackage :experiment.analysis
  (:nicknames :exp.analysis :analysis)
  (:use :cl)
  (:export :logfile
           :state
           :lines
           :tags
           :states
           :tag-start
           :tag-end
           :tag-text
           :correct-p
           :complete-p
           :duration
           :line-time
           :line-id
           :line-tag
           :line-keys
           :with-spreadsheets
           :experiment
           :message
           :click-message
           :timer-message
           :crosshair
           :fmri-crosshair
           :instructions
           :click-instructions
           :end
           :nback
           :sync-nback
           :synchronize-pulse
           :reward
           :start-recording
           :stop-recording
           :audio-record
           :subsequence
           :kp-message
           :dummy-synchronize-pulse
           :kbd-nback
           :control-panel
           :block-start
           :kp-block-start
           :nav-message
           :extract-key
           :extract-keys
           :extract-time
           :count-lines-if
           :count-tag
           :count-matches
           :average
           :avg
           :avg*
           :sum
           :dump-row
           :parse-duration
           :parse-correct-p
           :parse-complete-p
           :sanity-check
           :tag-inside-p
           :add-tag
           :seconds
           :bool
           :id
           :just-states
           :*summarize-function*
           :ensure-analysis
           :analysis-subjects
           :scan
           :dump
           :subjects
           :drop
           :clear
           :log-file-regexp
           :log-file-slurp
           :stimulus-response
           :input-start
           :input-duration
           :feedback
           :feedback-duration
           :presentation-duration
           :answer
           :session
           :make-session
           :session-name
           :session-date
           :session-state
           :session-blocks
           :session-problems
           :sheet-style))

(in-package :analysis)

;;(defpackage #:annotate-wave)
(defstruct tag
  start end text used)

(defstruct tag-file
  name id timestamp)

(defstruct session
  state blocks problems)

(defun session-name (session)
  (or (extract-key (session-state session) 'start :session nil)
      "unknown"))

(defun session-date (session)
  (extract-key (session-state session) 'start :date nil))

(defclass logfile ()
  ((lines :initarg :lines :accessor lines)
   (tags :initarg :tags :accessor tags)
   (id :initarg :id :accessor id)
   (states :initarg :states :accessor states)))

(defgeneric parse-state (log state-lines)
  (:documentation "Gather statistics from the state lines and return a
class containing all the data."))

(defclass state ()
  ((lines :initarg :lines :accessor lines)
   (tags :initform nil :accessor tags)
   (correct-p :accessor correct-p)
   (complete-p :accessor complete-p)
   (duration :accessor duration)))

(defgeneric parse-duration (state))
(defgeneric parse-correct-p (state))
(defgeneric sanity-check (state)
  (:method-combination and))
(defgeneric parse-complete-p (state))
(defgeneric add-tag (state tag))

;; standard state classes
(defclass experiment (state)
  ((date :accessor date)))
(defclass message (state) ())
(defclass click-message (state) ())
(defclass timer-message (state) ())
(defclass crosshair (state) ())
(defclass fmri-crosshair (state) ())
(defclass end (state) ())
(defclass instructions (state) ())
(defclass click-instructions (state) ())
(defclass nback (state) ())
(defclass sync-nback (state) ())
(defclass synchronize-pulse (state) ())
(defclass start-recording (state) ())
(defclass stop-recording (state) ())
(defclass audio-record (state) ())
(defclass reward (state) ())
(defclass subsequence (state) ())
(defclass kp-message (state) ())
(defclass dummy-synchronize-pulse (state) ())
(defclass kbd-nback (state) ())
(defclass control-panel (state) ())
(defclass block-start (state) ())
(defclass kp-block-start (block-start) ())
(defclass nav-message (state) ())

(defclass stimulus-response (state)
  ((input-start :accessor stimulus-response-input-start)
   (input-duration :accessor stimulus-response-input-duration)
   (presentation-duration :accessor stimulus-response-presentation-duration)
   (feedback-duration :accessor stimulus-response-feedback-duration)
   (feedback :accessor stimulus-response-feedback)
   (answer :accessor stimulus-response-answer)))

;; First pass on the logs: slurp them into a list of states

(defstruct line
  time id tag keys)

(defun slurp-stream (stream)
  (loop for line = (read stream nil stream)
     until (eq line stream)
     collect (make-line :time (first line) :id (second line) :tag (third line) :keys (cdddr line))))

(defun slurp-file (file)
  (with-open-file (stream file)
    (slurp-stream stream)))

(defun read-tags-file (file)
  (with-open-file (stream file)
    (let* ((*package* (find-package :experiment.analysis))
           (tags (read stream)))
      (dolist (i tags)
        (setf (tag-start i) (* (tag-start i) 100)
              (tag-end i) (* (tag-end i) 100)))
      tags)))

(defmethod read-states (lines)
  (loop
     for last = nil then i
     for i in lines
     for state = (list i) then (cons i state)
     when (and last
               (or (not (eq (line-id i) (line-id last)))
                   (string= (line-tag i) 'start)))
     collect (prog1
                 ;; state's latest addition is from the next state, so
                 ;; ditch it.
                 (make-instance (line-id (second state))
                                :lines (reverse (cdr state)))
               ;; (print "----")
               ;; (print (cdr state))
               (setf state (list i)))
     into ret
     finally (return (append ret (list (make-instance (line-id (first state))
                                                      :lines (reverse state)))))))

(defun tag-inside-p (obj tag)
  ;; (print (list (line-time (first (lines obj)))
  ;;              (tag-start tag)
  ;;              (line-time (first (last (lines obj))))))
  (and (>= (length (lines obj)) 2)
       (<= (line-time (first (lines obj)))
           (tag-start tag)
           (line-time (first (last (lines obj)))))))

(defun format-datetime (time)
  (multiple-value-bind (s m h d mo y) (decode-universal-time time)
    (format nil "~2,'0d:~2,'0d:~2,'0d ~2,'0d/~2,'0d/~d" h m s d mo y)))

(defun distribute-tags-to-states (tag-files tags lines states)
  ;; The assumption is that tags is a list of lists of tags sorted
  ;; chronologically.
  (declare (ignore lines))
  (labels ((recording-p (s)
             (and (typep s 'audio-record)
                  (string= (line-tag (first (lines s))) :start)))
           (experiment-state-p (s)
             (and (typep s 'experiment)
                  (string= (line-tag (first (lines s))) :start))))
    ;; (let ((recordings (count-if #'recording-p states)))
    ;;   (unless (= recordings (length tags))
    ;;     (warn "I have ~D tag files but found ~D sessions in the log file. I'll try to figure it out."
    ;;           (length tags) recordings)))
    (loop for s in states
          with remaining-tags = tags
          with remaining-tag-files = tag-files
          with session-tags = nil
          with exp-state = nil
          with exp-start-time = nil
          when (experiment-state-p s)
            do (setf exp-state s
                     exp-start-time (ppcre:register-groups-bind (h m s d mo y) ("^(\\d+):(\\d+):(\\d+) (\\d+)/(\\d+)/(\\d+)$" (extract-key exp-state 'start :date))
                                      (apply 'encode-universal-time
                                             (mapcar 'parse-integer (list s m h d mo y)))))
          when (recording-p s)
            do (tagbody
                  try-again
                  (if remaining-tags
                      (let ((diff (- (tag-file-timestamp (first remaining-tag-files)) exp-start-time)))
                        (cond
                          ((< diff 0)
                           (warn "Tag file not used (~a) because it doesn't match session ~s (~a)"
                                 (format-datetime (tag-file-timestamp (first remaining-tag-files)))
                                 (extract-key exp-state 'start :session)
                                 (format-datetime exp-start-time))
                           (pop remaining-tag-files)
                           (pop remaining-tags)
                           (go try-again))
                          ((< diff 2)
                           (pop remaining-tag-files)
                           (setf session-tags (sort (copy-list (pop remaining-tags)) '< :key 'tag-start))
                           ;; align tags
                           (dolist (tag session-tags)
                             (incf (tag-start tag) (line-time (first (lines s))))
                             (incf (tag-end tag) (line-time (first (lines s))))))
                          (t
                           (warn "No tags for session ~s (~a) because it doesn't match tags file (~a)"
                                 (extract-key exp-state 'start :session)
                                 (format-datetime exp-start-time)
                                 (format-datetime (tag-file-timestamp (first remaining-tag-files))))
                           (setf session-tags nil))))
                      (setf session-tags nil)))
          do (dolist (tag session-tags)
               (when (tag-inside-p s tag)
                 (assert (not (tag-used tag)))
                 (setf (tag-used tag) t)
                 (add-tag s tag))))
    ;; ensure that they were all used
    (let ((unused-tags (loop for session in tags
                             append (loop for tag in session
                                          unless (tag-used tag)
                                            collect tag))))
      (when (plusp (length unused-tags))
        (warn "~D unused tag~P: ~{~S~^, ~}" (length unused-tags) (length unused-tags) (mapcar 'tag-text unused-tags))))))

;; (defun distribute-tags-to-states-old (tags lines states)
;;   ;; The assumption is that tags is a list of lists of tags sorted
;;   ;; chronologically.
;;   (let ((times (loop for l in lines
;;                      when (and (string= (line-id l) :audio-record)
;;                                (string= (line-tag l) :start))
;;                        collect (line-time l))))
;;     (assert (= (length times) (length tags))
;;             () "I have ~D tag files but can only find ~D sessions in the log file."
;;             (length tags) (length times))
;;     (let ((tag-list (loop for tg in tags
;;                           for tm in times
;;                           do (dolist (i tg)
;;                                (incf (tag-start i) tm)
;;                                (incf (tag-end i) tm))
;;                           append tg)))
;;       ;; FIXME: this could be done a bit better
;;       (dolist (s states)
;;         (dolist (tag tag-list)
;;           (when (tag-inside-p s tag)
;;             ;;(print `(oh good ,tag))
;;             (setf (tag-used tag) t)
;;             (add-tag s tag))))
;;       (let ((unused-tags (loop for tag in tag-list
;;                                unless (tag-used tag)
;;                                  collect tag)))
;;         (when (plusp (length unused-tags))
;;           (warn "~D unused tags: ~s" (length unused-tags) unused-tags))))))

;; Fill in the default statistics

(defmethod add-tag (obj tag)
  ;; They go on the end of the list to preserve order
  (setf (tags obj) (nconc (tags obj) (list tag))))

(defmethod parse-duration ((obj state))
  (- (or (extract-time obj 'end nil)
         (line-time (car (last (lines obj)))))
     (or (extract-time obj 'start nil)
         (line-time (first (lines obj))))))

(defmethod parse-correct-p ((obj state))
  nil)

(defmethod parse-complete-p ((obj state))
  (string= (line-tag (car (last (lines obj)))) 'end))

(defmethod sanity-check and ((obj state))
  t)

(defmethod initialize-instance :after ((obj state) &key)
  (setf (duration obj) (parse-duration obj)
        (correct-p obj) (parse-correct-p obj)
        (complete-p obj) (parse-complete-p obj)))

(defmethod shared-initialize :after ((obj experiment) slots &key)
  (declare (ignore slots))
  (setf (date obj) (extract-key obj 'start :date nil)))

(defmethod shared-initialize :after ((obj stimulus-response) slots &key)
  (declare (ignore slots))
  (with-slots (input-start input-duration presentation-duration
               feedback-duration feedback answer) obj
    (let* ((start (extract-time obj 'start nil))
           (end (extract-time obj 'end nil))
           (input-start-time (extract-time obj 'start-input nil))
           (feedback-start-time (extract-time obj 'feedback nil)))
      (setf input-start (when input-start-time
                          (- input-start-time start))
            input-duration (when (and (or input-start-time
                                          (not (extract-key obj 'start :presentation)))
                                      feedback-start-time)
                             (- feedback-start-time (or input-start-time
                                                                 start)))
            presentation-duration (when input-start-time
                                    (- input-start-time start))
            feedback-duration (when (and feedback-start-time end)
                                (- end feedback-start-time))
            feedback (extract-key obj 'start :feedback nil)
            answer (if (eq (extract-key obj 'feedback :how nil) :submit)
                       (or (extract-key obj 'feedback :answer nil)
                           ;; old versions didn't report the answer,
                           ;; so extract it from the key presses.
                           (loop for i in (lines obj)
                                 when (string= (line-tag i) 'keypress)
                                   collect (getf (line-keys i) :key) into s
                                 finally (return (coerce s 'string))))
                       :timeout)))))

(defmethod parse-correct-p ((obj stimulus-response))
  (extract-key obj 'feedback :correctp nil))

;;; statistics gathering helper functions

;; (defun seconds (time)
;;   (/ time internal-time-units-per-second))

(defun bool (stat)
  (if stat "Yes" "No"))

(defun extract-line-slot (state tag slot &optional (error t))
  (let ((line (find tag (lines state) :key 'line-tag :test 'string=)))
    (if line
        (funcall slot line)
      (when error (assert line)))))

(defun extract-time (state tag &optional (error t))
  (extract-line-slot state tag 'line-time error))

(defun extract-key (state tag key &optional (error t) default)
  (getf (extract-line-slot state tag 'line-keys error) key default))

(defun extract-keys (state tag key)
  (loop for i in (lines state)
        when (and (string= tag (line-tag i))
                  (getf (line-keys i) key))
          collect (getf (line-keys i) key)))

(defun count-lines-if (state fn)
  (loop for i in (lines state)
        count (funcall fn i)))

(defun count-tag (state tag)
  (count-lines-if state (lambda (x) (eq (line-tag x) tag))))

(defun count-matches (state tag &rest keys &key &allow-other-keys)
  (count-lines-if state
                  (lambda (l)
                    (and (string= (line-tag l) tag)
                         (loop for i = keys then (cddr i)
                              while i
                              for k = (first i)
                              for v = (second i)
                              always (eql (getf (line-keys l) k) v))))))

;;; summarizing helper functions

(defun avg (&rest numbers)
  (avg* numbers))

(defun avg* (numbers)
  (unless (zerop (length numbers))
    (/ (reduce '+ numbers) (length numbers))))

(defun average (states slot &key (key 'identity))
  (if (plusp (length states))
      (/ (loop for i in states
	    sum (funcall key (slot-value i slot)))
	 (length states))
      0))

(defun sum (states slot &key (key 'identity))
  (loop for i in states
           sum (funcall key (slot-value i slot))))

;;; reporting helper functions

;; (defun summarize-row (states slots &rest formatters)
;;   )

;; (defun just-states (log type &key block-separator (only-complete t) section-names)
;;   (loop for i in (states log)
;;      for section-break-p = (and (typep i 'experiment)
;;                                 ;; resume doesn't count as a section break
;;                                 (not (or (eq (extract-key i 'start :session nil) :resume)
;;                                          (extract-key i 'start :resume nil))))
;;      for block-break-p = (and block-separator
;;                               (typep i block-separator))
;;      with section-name = nil
;;      when (and (typep i type)
;;                (or (not only-complete)
;;                    (complete-p i)))
;;      collect i into section
;;      when (and section-break-p section)
;;      collect (prog1
;;                  (if section-names
;;                      (cons section-name section)
;;                      section)
;;                ;;(print section-name)
;;                (setf section nil)) into session
;;      when (and section-break-p (extract-key i 'start :session nil))
;;      do (setf section-name (extract-key i 'start :session nil))
;;      finally (return (append
;;                       session
;;                       (when section
;;                         ;;(print section-name)
;;                         (list (if section-names
;;                                   (cons section-name section)
;;                                   section)))))))

;; (defun just-states (log type &key block-separators (only-complete t) section-names)
;;   (loop for i in (states log)
;;      for section-break-p = (and (typep i 'experiment)
;;                                 ;; resume doesn't count as a section break
;;                                 (not (or (eq (extract-key i 'start :session nil) :resume)
;;                                          (extract-key i 'start :resume nil))))
;;      for block-break-p = (and block-separators
;;                               (find-if (lambda (x) (typep i x)) block-separators))
;;      with section-name = nil
;;      when (and (typep i type)
;;                (or (not only-complete)
;;                    (complete-p i)))
;;      collect i into block
;;      when (and block-break-p block)
;;      collect (prog1
;;                  block
;;                (setf block nil)) into section
;;      when (and section-break-p (or block section))
;;      collect (prog2
;;                  (when block
;;                    (setf section (append section (if block-separators
;;                                                      (list block)
;;                                                      block))
;;                          block nil))
;;                  (if section-names
;;                      (cons section-name section)
;;                      section)
;;                ;;(print section-name)
;;                (setf section nil)) into session
;;      when (and section-break-p (extract-key i 'start :session nil))
;;      do (setf section-name (extract-key i 'start :session nil))
;;      finally (return
;;                (progn
;;                  (when block
;;                    (if block-separators
;;                        (if section
;;                            (setf section (append section (list block)))
;;                            (nconc (u:last1 session) (list block)))
;;                        (setf section (append section block))))
;;                  (when section
;;                    (setf session (append session
;;                                          (list (if section-names
;;                                                    (cons section-name section)
;;                                                    section)))))
;;                  session))))

(defun just-states (log types &key block-separators (only-complete t))
  (unless (listp types)
    (setf types (list types)))
  (labels ((section-break-p (s)
             (and (typep s 'experiment)
                  ;; resume doesn't count as a section break
                  (not (or (eq (extract-key s 'start :session nil) :resume)
                           (extract-key s 'start :resume nil)))))
           (block-break-p (s)
             (some (lambda (type)
                     (typep s type))
                   block-separators))
           ;; (skip-break-states (state)
           ;;   (loop for s = (first states)
           ;;         while (or (section-break-p s)
           ;;                   (block-break-p s))
           ;;         do (pop states))
           ;;   states)
           (pop-block (states)
             ;;(setf states (skip-break-states states))
             (loop for rest = states then (cdr rest)
                   while rest
                   for s = (first rest)
                   when (block-break-p s)
                     do (pop rest)
                   until (or (section-break-p s)
                             (block-break-p s))
                   when (and (some (lambda (type) (typep s type)) types)
                             (or (not only-complete)
                                 (complete-p s)))
                   collect s into block
                   finally (return (list block rest))))
           (pop-session (states section-state)
             (loop with next-section-state = nil
                   for ret = (pop-block states) then (pop-block rest)
                   for b = (first ret)
                   for rest = (second ret)
                   for s = (first rest)
                   when b
                     if block-separators
                       collect b into session
                   else
                     append b into session
                   while rest
                   when (section-break-p s)
                     do (setf next-section-state s)
                        (pop rest)
                   until (section-break-p s)
                   finally (return (list (if session
                                             (if block-separators
                                                 (make-session :state section-state
                                                               :blocks session)
                                                 (make-session :state section-state
                                                               :problems session))
                                             nil)
                                         next-section-state
                                         rest)))))
  (loop with states = (states log)
        with section-state = nil
        for ret = (pop-session states section-state)
        for s = (first ret)
        when s
          collect s
        do (setf section-state (second ret)
                 states (third ret))
        while states)))

;;;;;;;; simple command interface

(defstruct analysis
  subjects pathname)

(defvar *analysis* nil)

(defvar *warnings* nil)

(defun print-warnings ()
  (dolist (w (reverse *warnings*))
    (write-line w)))

(defun report-warning (fmt &rest args)
  (push (apply 'format nil fmt args) *warnings*))

(defmacro with-warnings (() &body body)
  `(let ((*warnings* nil))
     (handler-bind
         ((warning (lambda (c)
                     (report-warning "Warning: ~a" c)
                     (muffle-warning))))
       (prog1 (progn ,@body)
         (print-warnings)))))

#+lispworks
(defun choose-directory (&optional start-dir)
  (multiple-value-bind (result success)
      (capi:prompt-for-directory "Select a directory to scan" :pathname start-dir)
    (when success
      result)))

#+ccl
(defun choose-directory (&optional base)
  (declare (ignorable base))
  #+easygui
  (easygui:choose-directory-dialog :directory base)
  #-easygui
  (error "This code must be run from the Clozure CL IDE"))

#+allegro
(defun choose-directory (&optional start-dir)
  (declare (ignore base))
  (cg:ask-user-for-directory :prompt "Select a directory to scan"))

#-(or lispworks ccl allegro)
(defun choose-directory (&optional base)
  (error "CHOOSE-DIRECTORY is unimplemented on this platform."))

(defun ensure-analysis ()
  (or *analysis*
      (setf *analysis* (make-analysis))))

(defvar *summarize-function* nil)

(defun read-subject-file (id file)
  (let* ((lines (log-file-slurp file))
         (log (make-instance 'logfile
                             :lines lines
                             :tags nil
                             :id id
                             :states (read-states lines))))
    (unless (every 'sanity-check (states log))
      (report-warning "Sanity check fails for subject ~a~%" id))
    (when *summarize-function*
      (funcall *summarize-function* log))
    log))

(defun merge-subjects (log1 log2)
  (setf (lines log1) (append (lines log1) (lines log2))
        (states log1) (append (states log1) (states log2))
        (tags log1) (append (tags log1) (tags log2)))
  (unless (every 'sanity-check (states log1))
    (report-warning "Sanity check fails for subject ~a~%" (id log1)))
  log1)

(defun read-subject (id files tag-files)
  (let* ((sorted-tag-files (sort tag-files #'< :key #'tag-file-timestamp))
         (tags (loop for tf in sorted-tag-files
                     collect (read-tags-file (tag-file-name tf)))))
    (loop for f in (cdr files)
          with log = (read-subject-file id (first files))
          for l = (read-subject-file id f)
          do (merge-subjects log l)
          finally (progn
                    (when tag-files
                      (distribute-tags-to-states sorted-tag-files tags (lines log) (states log)))
                    (return log)))))

(defun collect-dirs (base)
  (let* ((files #+ccl
                (directory (make-pathname :name :wild :type nil :defaults base)
                           :directories t :files nil)
                #+lispworks
                (directory (make-pathname :name nil :type nil :defaults base))
                #+allegro (directory (make-pathname :name nil :type nil :defaults base))
                #-(or ccl lispworks allegro)
                (error "COLLECT-DIRS: unimplemented"))
         (dirs (loop for f in files
                     unless (or (stringp (pathname-name f))
                                (stringp (pathname-type f))
                                (and (stringp (car (last (pathname-directory f))))
                                     (char= (char (car (last (pathname-directory f))) 0) #\.)))
                       collect f)))
    (if dirs
        (append dirs (mapcan #'collect-dirs dirs))
        nil)))

(defun scan-for (base-dir scan-function)
  (loop with things = (mapcan scan-function (cons base-dir (collect-dirs base-dir)))
        with alist = (list)
        for x in things
        for a = (assoc (first x) alist :test #'equal)
        if a
          do (nconc a (cdr x))
        else
          do (push x alist)
        finally (return alist)))

(defun scan-dir-for-tag-files (base-dir)
  "Return a list of subject files."
  (format nil "Scanning for tag files in ~a ..." base-dir)
  (finish-output)
  (let* ((files (directory (make-pathname :name :wild :type "tags" :defaults base-dir))))
    (loop for f in files
          with tag-files = nil
          do (ppcre:register-groups-bind (id year mon day hour min sec) ("^audio-([0-9a-zA-Z]+)--(\\d+)-(\\d+)-(\\d+)--(\\d+)-(\\d+)-(\\d+)$" (pathname-name f))
               (pushnew (make-tag-file :id id
                                       :name f
                                       :timestamp (apply 'encode-universal-time
                                                         (mapcar 'parse-integer (list sec min hour day mon year))))
                        tag-files))
          finally (return tag-files))))

(defun scan-dir-for-subjects (base-dir)
  "Return a list of subject files."
  (format nil "Scanning ~a ..." base-dir)
  (finish-output)
  (let* ((files (directory (make-pathname :name :wild :type "txt" :defaults base-dir))))
    (loop for f in files
          with subjects = nil
          with regexp = (log-file-regexp)
          do (ppcre:register-groups-bind (subject) (regexp (pathname-name f))
               (push (list subject f) subjects))
          finally (return subjects))))

(defun scan-for-subjects (base-dir)
  (scan-for base-dir 'scan-dir-for-subjects))

(defun scan-for-tag-files (base-dir)
  (scan-for base-dir 'scan-dir-for-tag-files))

(defun string-or-number< (a b)
  (let ((n1 (ignore-errors (parse-integer a)))
        (n2 (ignore-errors (parse-integer b))))
    (if (and n1 n2)
        (< n1 n2)
        (string< a b))))

(defun scan (&key (dir (choose-directory)) (analysis (ensure-analysis)))
  (if dir
      (let ((subjects (sort (scan-for-subjects dir) 'string-or-number< :key 'first))
            (tag-files (scan-for-tag-files dir))
            new dups)
        (loop for rest on subjects
              for s = (first rest)
              if (find (first s) (analysis-subjects analysis) :key #'id :test #'equal)
                collect s into d
              else
                collect s into n
              finally (setf new n
                            dups d))
        (when dups
          (format t "Skipping ~D existing subject~p: ~{~a~^ ~}~%" (length dups) (length dups) (mapcar #'first dups)))
        (when new
          (setf (analysis-pathname analysis) dir)
          (format t "Found ~D new subject log~p: ~{~a~^ ~}~%" (length new) (length new) (mapcar #'first new)))
        (setf (analysis-subjects analysis)
              (nconc (analysis-subjects analysis)
                     (loop for tmp in new
                           for id = (first tmp)
                           for files = (rest tmp)
                           unless (find id dups :test #'equal)
                             collect (progn
                                       (format t "~&Reading subject ~A..." id)
                                       (finish-output)
                                       (with-warnings ()
                                         (prog1
                                             (read-subject id files tag-files)
                                           (format t "~%")
                                           (finish-output)))))))
        (format t "~&Done.~%"))
      (format t "No directory supplied. Aborting.~%"))
  (values))

(defun dump (name sheets &key summary-sheets single (analysis (ensure-analysis)))
  (if (analysis-subjects analysis)
      (let ((file (make-pathname :name name :type "xlsx" :defaults (analysis-pathname analysis)))
            (ss (make-instance 'excel:spreadsheet)))
        (if single
            (format t "Dumping sheets:")
            (format t "Dumping subjects:"))
        (finish-output)
        (setf (excel:sheets (excel:workbook ss))
              (append
               (loop :for i :in summary-sheets
                     :collect (funcall i (analysis-subjects analysis))
                     :do (format t " ~a" i)
                         (finish-output))
               (if single
                   (loop :for sheet :in sheets
                         :collect (funcall sheet (analysis-subjects analysis))
                         :do (format t " ~a" sheet)
                             (finish-output))
                   (loop :for i :in (analysis-subjects analysis)
                         :append (loop :for sheet :in sheets
                                   :collect (funcall sheet i))
                         :do (format t " ~a" (id i))
                             (finish-output)))))
        (excel:save-spreadsheet ss file :if-exists :supersede)
        (format t "~&To: ~a~%" file)
        (format t "Done.~%"))
      (format t "No subjects to dump.~%"))
  (values))


(defun subjects (&key (analysis (ensure-analysis)))
  (if (analysis-subjects analysis)
      (format t "Subjects: ~{~a ~}~%" (mapcar 'id (analysis-subjects analysis)))
      (format t "No subjects.~%"))
  (values))

(defun drop (id &key (analysis (ensure-analysis)))
  (setf id (if (stringp id)
               id
               (prin1-to-string id)))
  (if (find id (analysis-subjects analysis) :key 'id :test 'equal)
      (format t "Deleting subject ~a.~%" id)
      (format t "Subject ~a not found.~%" id))
  (setf (analysis-subjects analysis) (delete id (analysis-subjects analysis) :key 'id :test 'equal))
  (values))

(defun clear (&key (analysis (ensure-analysis)))
  (if (analysis-subjects analysis)
      (format t "Clearing subjects ~{~a~^, ~}.~%" (mapcar 'id (analysis-subjects analysis)))
      (format t "No subjects to clear.~%"))
  (setf (analysis-subjects analysis) nil)
  (values))
